home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / nnbabyl.el.z / nnbabyl.el
Encoding:
Text File  |  1998-10-28  |  20.4 KB  |  626 lines
  1. ;;; nnbabyl.el --- rmail mbox access for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; For an overview of what the interface functions do, please see the
  28. ;; Gnus sources.  
  29.  
  30. ;;; Code:
  31.  
  32. (require 'nnheader)
  33. (require 'rmail)
  34. (require 'nnmail)
  35. (require 'nnoo)
  36. (eval-when-compile (require 'cl))
  37.  
  38. (nnoo-declare nnbabyl)
  39.  
  40. (defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL")
  41.   "The name of the rmail box file in the users home directory.")
  42.  
  43. (defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active")
  44.   "The name of the active file for the rmail box.")
  45.  
  46. (defvoo nnbabyl-get-new-mail t
  47.   "If non-nil, nnbabyl will check the incoming mail file and split the mail.")
  48.  
  49. (defvoo nnbabyl-prepare-save-mail-hook nil
  50.   "Hook run narrowed to an article before saving.")
  51.  
  52.  
  53.  
  54. (defvar nnbabyl-mail-delimiter "\^_")
  55.  
  56. (defconst nnbabyl-version "nnbabyl 1.0"
  57.   "nnbabyl version.")
  58.  
  59. (defvoo nnbabyl-mbox-buffer nil)
  60. (defvoo nnbabyl-current-group nil)
  61. (defvoo nnbabyl-status-string "")
  62. (defvoo nnbabyl-group-alist nil)
  63. (defvoo nnbabyl-active-timestamp nil)
  64.  
  65. (defvoo nnbabyl-previous-buffer-mode nil)
  66.  
  67. (eval-and-compile
  68.   (autoload 'gnus-set-text-properties "gnus-ems"))
  69.  
  70.  
  71.  
  72. ;;; Interface functions
  73.  
  74. (nnoo-define-basics nnbabyl)
  75.  
  76. (deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
  77.   (save-excursion
  78.     (set-buffer nntp-server-buffer)
  79.     (erase-buffer)
  80.     (let ((number (length articles))
  81.       (count 0)
  82.       (delim (concat "^" nnbabyl-mail-delimiter))
  83.       article art-string start stop)
  84.       (nnbabyl-possibly-change-newsgroup group server)
  85.       (while (setq article (pop articles))
  86.     (setq art-string (nnbabyl-article-string article))
  87.     (set-buffer nnbabyl-mbox-buffer)
  88.     (beginning-of-line)
  89.     (when (or (search-forward art-string nil t)
  90.           (search-backward art-string nil t))
  91.       (re-search-backward delim nil t)
  92.       (while (and (not (looking-at ".+:"))
  93.               (zerop (forward-line 1))))
  94.       (setq start (point))
  95.       (search-forward "\n\n" nil t)
  96.       (setq stop (1- (point)))
  97.       (set-buffer nntp-server-buffer)
  98.       (insert "221 ")
  99.       (princ article (current-buffer))
  100.       (insert " Article retrieved.\n")
  101.       (insert-buffer-substring nnbabyl-mbox-buffer start stop)
  102.       (goto-char (point-max))
  103.       (insert ".\n"))
  104.     (and (numberp nnmail-large-newsgroup)
  105.          (> number nnmail-large-newsgroup)
  106.          (zerop (% (incf count) 20))
  107.          (nnheader-message 5 "nnbabyl: Receiving headers... %d%%"
  108.                    (/ (* count 100) number))))
  109.  
  110.       (and (numberp nnmail-large-newsgroup)
  111.        (> number nnmail-large-newsgroup)
  112.        (nnheader-message 5 "nnbabyl: Receiving headers...done"))
  113.  
  114.       (set-buffer nntp-server-buffer)
  115.       (nnheader-fold-continuation-lines)
  116.       'headers)))
  117.  
  118. (deffoo nnbabyl-open-server (server &optional defs)
  119.   (nnoo-change-server 'nnbabyl server defs)
  120.   (cond 
  121.    ((not (file-exists-p nnbabyl-mbox-file))
  122.     (nnbabyl-close-server)
  123.     (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
  124.    ((file-directory-p nnbabyl-mbox-file)
  125.     (nnbabyl-close-server)
  126.     (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file))
  127.    (t
  128.     (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server
  129.              nnbabyl-mbox-file)
  130.     t)))
  131.  
  132. (deffoo nnbabyl-close-server (&optional server)
  133.   ;; Restore buffer mode.
  134.   (when (and (nnbabyl-server-opened)
  135.          nnbabyl-previous-buffer-mode)
  136.     (save-excursion
  137.       (set-buffer nnbabyl-mbox-buffer)
  138.       (narrow-to-region
  139.        (caar nnbabyl-previous-buffer-mode)
  140.        (cdar nnbabyl-previous-buffer-mode))
  141.       (funcall (cdr nnbabyl-previous-buffer-mode))))
  142.   (nnoo-close-server 'nnbabyl server)
  143.   (setq nnbabyl-mbox-buffer nil)
  144.   t)
  145.  
  146. (deffoo nnbabyl-server-opened (&optional server)
  147.   (and (nnoo-current-server-p 'nnbabyl server)
  148.        nnbabyl-mbox-buffer
  149.        (buffer-name nnbabyl-mbox-buffer)
  150.        nntp-server-buffer
  151.        (buffer-name nntp-server-buffer)))
  152.  
  153. (deffoo nnbabyl-request-article (article &optional newsgroup server buffer)
  154.   (nnbabyl-possibly-change-newsgroup newsgroup server)
  155.   (save-excursion
  156.     (set-buffer nnbabyl-mbox-buffer)
  157.     (goto-char (point-min))
  158.     (when (search-forward (nnbabyl-article-string article) nil t)
  159.       (let (start stop summary-line)
  160.     (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
  161.     (while (and (not (looking-at ".+:"))
  162.             (zerop (forward-line 1))))
  163.     (setq start (point))
  164.     (or (and (re-search-forward 
  165.           (concat "^" nnbabyl-mail-delimiter) nil t)
  166.          (forward-line -1))
  167.         (goto-char (point-max)))
  168.     (setq stop (point))
  169.     (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
  170.       (set-buffer nntp-server-buffer)
  171.       (erase-buffer)
  172.       (insert-buffer-substring nnbabyl-mbox-buffer start stop)
  173.       (goto-char (point-min))
  174.       ;; If there is an EOOH header, then we have to remove some
  175.       ;; duplicated headers. 
  176.       (setq summary-line (looking-at "Summary-line:"))
  177.       (when (search-forward "\n*** EOOH ***" nil t)
  178.         (if summary-line
  179.         ;; The headers to be deleted are located before the
  180.         ;; EOOH line...
  181.         (delete-region (point-min) (progn (forward-line 1)
  182.                           (point)))
  183.           ;; ...or after.
  184.           (delete-region (progn (beginning-of-line) (point))
  185.                  (or (search-forward "\n\n" nil t)
  186.                  (point)))))
  187.       (if (numberp article) 
  188.           (cons nnbabyl-current-group article)
  189.         (nnbabyl-article-group-number)))))))
  190.  
  191. (deffoo nnbabyl-request-group (group &optional server dont-check)
  192.   (let ((active (cadr (assoc group nnbabyl-group-alist))))
  193.     (save-excursion
  194.       (cond 
  195.        ((or (null active)
  196.         (null (nnbabyl-possibly-change-newsgroup group server)))
  197.     (nnheader-report 'nnbabyl "No such group: %s" group))
  198.        (dont-check
  199.     (nnheader-report 'nnbabyl "Selected group %s" group)
  200.     (nnheader-insert ""))
  201.        (t
  202.     (nnheader-report 'nnbabyl "Selected group %s" group)
  203.     (nnheader-insert "211 %d %d %d %s\n" 
  204.              (1+ (- (cdr active) (car active)))
  205.              (car active) (cdr active) group))))))
  206.  
  207. (deffoo nnbabyl-request-scan (&optional group server)
  208.   (nnbabyl-read-mbox)
  209.   (nnmail-get-new-mail 
  210.    'nnbabyl 
  211.    (lambda ()
  212.      (save-excursion
  213.        (set-buffer nnbabyl-mbox-buffer)
  214.        (save-buffer)))
  215.    nnbabyl-mbox-file group
  216.    (lambda ()
  217.      (save-excursion
  218.        (let ((in-buf (current-buffer)))
  219.      (goto-char (point-min))
  220.      (while (search-forward "\n\^_\n" nil t)
  221.        (delete-char -1))
  222.      (set-buffer nnbabyl-mbox-buffer)
  223.      (goto-char (point-max))
  224.      (search-backward "\n\^_" nil t)
  225.      (goto-char (match-end 0))
  226.      (insert-buffer-substring in-buf)))
  227.      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
  228.  
  229. (deffoo nnbabyl-close-group (group &optional server)
  230.   t)
  231.  
  232. (deffoo nnbabyl-request-create-group (group &optional server) 
  233.   (nnmail-activate 'nnbabyl)
  234.   (unless (assoc group nnbabyl-group-alist)
  235.     (setq nnbabyl-group-alist (cons (list group (cons 1 0))
  236.                     nnbabyl-group-alist))
  237.     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
  238.   t)
  239.  
  240. (deffoo nnbabyl-request-list (&optional server)
  241.   (save-excursion
  242.     (nnmail-find-file nnbabyl-active-file)
  243.     (setq nnbabyl-group-alist (nnmail-get-active))))
  244.  
  245. (deffoo nnbabyl-request-newgroups (date &optional server)
  246.   (nnbabyl-request-list server))
  247.  
  248. (deffoo nnbabyl-request-list-newsgroups (&optional server)
  249.   (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
  250.  
  251. (deffoo nnbabyl-request-expire-articles
  252.   (articles newsgroup &optional server force)
  253.   (nnbabyl-possibly-change-newsgroup newsgroup server)
  254.   (let* ((is-old t)
  255.      rest)
  256.     (nnmail-activate 'nnbabyl)
  257.  
  258.     (save-excursion 
  259.       (set-buffer nnbabyl-mbox-buffer)
  260.       (gnus-set-text-properties (point-min) (point-max) nil)
  261.       (while (and articles is-old)
  262.     (goto-char (point-min))
  263.     (if (search-forward (nnbabyl-article-string (car articles)) nil t)
  264.         (if (setq is-old
  265.               (nnmail-expired-article-p
  266.                newsgroup
  267.                (buffer-substring 
  268.             (point) (progn (end-of-line) (point))) force))
  269.         (progn
  270.           (nnheader-message 5 "Deleting article %d in %s..." 
  271.                     (car articles) newsgroup)
  272.           (nnbabyl-delete-mail))
  273.           (setq rest (cons (car articles) rest))))
  274.     (setq articles (cdr articles)))
  275.       (save-buffer)
  276.       ;; Find the lowest active article in this group.
  277.       (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
  278.     (goto-char (point-min))
  279.     (while (and (not (search-forward
  280.               (nnbabyl-article-string (car active)) nil t))
  281.             (<= (car active) (cdr active)))
  282.       (setcar active (1+ (car active)))
  283.       (goto-char (point-min))))
  284.       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  285.       (nconc rest articles))))
  286.  
  287. (deffoo nnbabyl-request-move-article 
  288.   (article group server accept-form &optional last)
  289.   (nnbabyl-possibly-change-newsgroup group server)
  290.   (let ((buf (get-buffer-create " *nnbabyl move*"))
  291.     result)
  292.     (and 
  293.      (nnbabyl-request-article article group server)
  294.      (save-excursion
  295.        (set-buffer buf)
  296.        (insert-buffer-substring nntp-server-buffer)
  297.        (goto-char (point-min))
  298.        (if (re-search-forward 
  299.         "^X-Gnus-Newsgroup:" 
  300.         (save-excursion (search-forward "\n\n" nil t) (point)) t)
  301.        (delete-region (progn (beginning-of-line) (point))
  302.               (progn (forward-line 1) (point))))
  303.        (setq result (eval accept-form))
  304.        (kill-buffer (current-buffer))
  305.        result)
  306.      (save-excursion
  307.        (set-buffer nnbabyl-mbox-buffer)
  308.        (goto-char (point-min))
  309.        (if (search-forward (nnbabyl-article-string article) nil t)
  310.        (nnbabyl-delete-mail))
  311.        (and last (save-buffer))))
  312.     result))
  313.  
  314. (deffoo nnbabyl-request-accept-article (group &optional server last)
  315.   (nnbabyl-possibly-change-newsgroup group server)
  316.   (nnmail-check-syntax)
  317.   (let ((buf (current-buffer))
  318.     result beg)
  319.     (and 
  320.      (nnmail-activate 'nnbabyl)
  321.      (save-excursion
  322.        (goto-char (point-min))
  323.        (search-forward "\n\n" nil t)
  324.        (forward-line -1)
  325.        (save-excursion
  326.      (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
  327.        (delete-region (point) (progn (forward-line 1) (point)))))
  328.        (let ((nnmail-split-methods
  329.           (if (stringp group) (list (list group "")) 
  330.         nnmail-split-methods)))
  331.      (setq result (car (nnbabyl-save-mail))))
  332.        (set-buffer nnbabyl-mbox-buffer)
  333.        (goto-char (point-max))
  334.        (search-backward "\n\^_")
  335.        (goto-char (match-end 0))
  336.        (insert-buffer-substring buf)
  337.        (when last
  338.      (save-buffer)
  339.      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
  340.        result))))
  341.  
  342. (deffoo nnbabyl-request-replace-article (article group buffer)
  343.   (nnbabyl-possibly-change-newsgroup group)
  344.   (save-excursion
  345.     (set-buffer nnbabyl-mbox-buffer)
  346.     (goto-char (point-min))
  347.     (if (not (search-forward (nnbabyl-article-string article) nil t))
  348.     nil
  349.       (nnbabyl-delete-mail t t)
  350.       (insert-buffer-substring buffer)
  351.       (save-buffer)
  352.       t)))
  353.  
  354. (deffoo nnbabyl-request-delete-group (group &optional force server)
  355.   (nnbabyl-possibly-change-newsgroup group server)
  356.   ;; Delete all articles in GROUP.
  357.   (if (not force)
  358.       ()                ; Don't delete the articles.
  359.     (save-excursion
  360.       (set-buffer nnbabyl-mbox-buffer)
  361.       (goto-char (point-min))
  362.       ;; Delete all articles in this group.
  363.       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
  364.         found)
  365.     (while (search-forward ident nil t)
  366.       (setq found t)
  367.       (nnbabyl-delete-mail))
  368.     (and found (save-buffer)))))
  369.   ;; Remove the group from all structures.
  370.   (setq nnbabyl-group-alist 
  371.     (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
  372.     nnbabyl-current-group nil)
  373.   ;; Save the active file.
  374.   (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  375.   t)
  376.  
  377. (deffoo nnbabyl-request-rename-group (group new-name &optional server)
  378.   (nnbabyl-possibly-change-newsgroup group server)
  379.   (save-excursion
  380.     (set-buffer nnbabyl-mbox-buffer)
  381.     (goto-char (point-min))
  382.     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
  383.       (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
  384.       found)
  385.       (while (search-forward ident nil t)
  386.     (replace-match new-ident t t)
  387.     (setq found t))
  388.       (and found (save-buffer))))
  389.   (let ((entry (assoc group nnbabyl-group-alist)))
  390.     (and entry (setcar entry new-name))
  391.     (setq nnbabyl-current-group nil)
  392.     ;; Save the new group alist.
  393.     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  394.     t))
  395.  
  396.  
  397. ;;; Internal functions.
  398.  
  399. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
  400. ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
  401. ;; delimiter line.
  402. (defun nnbabyl-delete-mail (&optional force leave-delim)
  403.   ;; Delete the current X-Gnus-Newsgroup line.
  404.   (or force
  405.       (delete-region
  406.        (progn (beginning-of-line) (point))
  407.        (progn (forward-line 1) (point))))
  408.   ;; Beginning of the article.
  409.   (save-excursion
  410.     (save-restriction
  411.       (widen)
  412.       (narrow-to-region
  413.        (save-excursion
  414.      (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
  415.      (if leave-delim (progn (forward-line 1) (point))
  416.        (match-beginning 0)))
  417.        (progn
  418.      (forward-line 1)
  419.      (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) 
  420.                      nil t)
  421.           (if (and (not (bobp)) leave-delim)
  422.               (progn (forward-line -2) (point))
  423.             (match-beginning 0)))
  424.          (point-max))))
  425.       (goto-char (point-min))
  426.       ;; Only delete the article if no other groups owns it as well.
  427.       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
  428.       (delete-region (point-min) (point-max))))))
  429.  
  430. (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
  431.   (when (and server 
  432.          (not (nnbabyl-server-opened server)))
  433.     (nnbabyl-open-server server))
  434.   (if (or (not nnbabyl-mbox-buffer)
  435.       (not (buffer-name nnbabyl-mbox-buffer)))
  436.       (save-excursion (nnbabyl-read-mbox)))
  437.   (or nnbabyl-group-alist
  438.       (nnmail-activate 'nnbabyl))
  439.   (if newsgroup
  440.       (if (assoc newsgroup nnbabyl-group-alist)
  441.       (setq nnbabyl-current-group newsgroup)
  442.     (nnheader-report 'nnbabyl "No such group in file"))
  443.     t))
  444.  
  445. (defun nnbabyl-article-string (article)
  446.   (if (numberp article)
  447.       (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" 
  448.           (int-to-string article) " ")
  449.     (concat "\nMessage-ID: " article)))
  450.  
  451. (defun nnbabyl-article-group-number ()
  452.   (save-excursion
  453.     (goto-char (point-min))
  454.     (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
  455.                 nil t)
  456.      (cons (buffer-substring (match-beginning 1) (match-end 1))
  457.            (string-to-int
  458.         (buffer-substring (match-beginning 2) (match-end 2)))))))
  459.  
  460. (defun nnbabyl-insert-lines ()
  461.   "Insert how many lines and chars there are in the body of the mail."
  462.   (let (lines chars)
  463.     (save-excursion
  464.       (goto-char (point-min))
  465.       (when (search-forward "\n\n" nil t) 
  466.     ;; There may be an EOOH line here...
  467.     (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
  468.       (search-forward "\n\n" nil t))
  469.     (setq chars (- (point-max) (point))
  470.           lines (max (- (count-lines (point) (point-max)) 1) 0))
  471.     ;; Move back to the end of the headers. 
  472.     (goto-char (point-min))
  473.     (search-forward "\n\n" nil t)
  474.     (forward-char -1)
  475.     (save-excursion
  476.       (when (re-search-backward "^Lines: " nil t)
  477.         (delete-region (point) (progn (forward-line 1) (point)))))
  478.     (insert (format "Lines: %d\n" lines))
  479.     chars))))
  480.  
  481. (defun nnbabyl-save-mail ()
  482.   ;; Called narrowed to an article.
  483.   (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
  484.     (nnbabyl-insert-lines)
  485.     (nnmail-insert-xref group-art)
  486.     (nnbabyl-insert-newsgroup-line group-art)
  487.     (run-hooks 'nnbabyl-prepare-save-mail-hook)
  488.     group-art))
  489.  
  490. (defun nnbabyl-insert-newsgroup-line (group-art)
  491.   (save-excursion
  492.     (goto-char (point-min))
  493.     (while (looking-at "From ")
  494.       (replace-match "Mail-from: From " t t)
  495.       (forward-line 1))
  496.     ;; If there is a C-l at the beginning of the narrowed region, this
  497.     ;; isn't really a "save", but rather a "scan".
  498.     (goto-char (point-min))
  499.     (or (looking-at "\^L")
  500.     (save-excursion
  501.       (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
  502.       (goto-char (point-max))
  503.       (insert "\^_\n")))
  504.     (if (search-forward "\n\n" nil t)
  505.     (progn
  506.       (forward-char -1)
  507.       (while group-art
  508.         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n" 
  509.                 (caar group-art) (cdar group-art)
  510.                 (current-time-string)))
  511.         (setq group-art (cdr group-art)))))
  512.     t))
  513.  
  514. (defun nnbabyl-active-number (group)
  515.   ;; Find the next article number in GROUP.
  516.   (let ((active (cadr (assoc group nnbabyl-group-alist))))
  517.     (if active
  518.     (setcdr active (1+ (cdr active)))
  519.       ;; This group is new, so we create a new entry for it.
  520.       ;; This might be a bit naughty... creating groups on the drop of
  521.       ;; a hat, but I don't know...
  522.       (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1)))
  523.                       nnbabyl-group-alist)))
  524.     (cdr active)))
  525.  
  526. (defun nnbabyl-read-mbox ()
  527.   (nnmail-activate 'nnbabyl)
  528.   (unless (file-exists-p nnbabyl-mbox-file)
  529.     ;; Create a new, empty RMAIL mbox file.
  530.     (save-excursion
  531.       (set-buffer (setq nnbabyl-mbox-buffer
  532.             (create-file-buffer nnbabyl-mbox-file)))
  533.       (setq buffer-file-name nnbabyl-mbox-file)
  534.       (insert "BABYL OPTIONS:\n\n\^_")
  535.       (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
  536.  
  537.   (if (and nnbabyl-mbox-buffer
  538.        (buffer-name nnbabyl-mbox-buffer)
  539.        (save-excursion
  540.          (set-buffer nnbabyl-mbox-buffer)
  541.          (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
  542.       () ; This buffer hasn't changed since we read it last.  Possibly.
  543.     (save-excursion
  544.       (let ((delim (concat "^" nnbabyl-mail-delimiter))
  545.         (alist nnbabyl-group-alist)
  546.         start end number)
  547.     (set-buffer (setq nnbabyl-mbox-buffer 
  548.               (nnheader-find-file-noselect 
  549.                nnbabyl-mbox-file nil 'raw)))
  550.     ;; Save previous buffer mode.
  551.     (setq nnbabyl-previous-buffer-mode 
  552.           (cons (cons (point-min) (point-max))
  553.             major-mode))
  554.  
  555.     (buffer-disable-undo (current-buffer))
  556.     (widen)
  557.     (setq buffer-read-only nil)
  558.     (fundamental-mode)
  559.  
  560.     ;; Go through the group alist and compare against
  561.     ;; the rmail file.
  562.     (while alist
  563.       (goto-char (point-max))
  564.       (when (and (re-search-backward
  565.               (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
  566.                   (caar alist)) nil t)
  567.              (> (setq number
  568.                   (string-to-number 
  569.                    (buffer-substring
  570.                 (match-beginning 1) (match-end 1))))
  571.             (cdadar alist)))
  572.         (setcdr (cadar alist) (1+ number)))
  573.       (setq alist (cdr alist)))
  574.     
  575.     ;; We go through the mbox and make sure that each and 
  576.     ;; every mail belongs to some group or other.
  577.     (goto-char (point-min))
  578.     (re-search-forward delim nil t)
  579.     (setq start (match-end 0))
  580.     (while (re-search-forward delim nil t)
  581.       (setq end (match-end 0))
  582.       (unless (search-backward "\nX-Gnus-Newsgroup: " start t)
  583.         (goto-char end)
  584.         (save-excursion
  585.           (save-restriction
  586.         (narrow-to-region (goto-char start) end)
  587.         (nnbabyl-save-mail)
  588.         (setq end (point-max)))))
  589.       (goto-char (setq start end)))
  590.     (when (buffer-modified-p (current-buffer))
  591.       (save-buffer))
  592.     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
  593.  
  594. (defun nnbabyl-remove-incoming-delims ()
  595.   (goto-char (point-min))
  596.   (while (search-forward "\^_" nil t)
  597.     (replace-match "?" t t)))
  598.  
  599. (defun nnbabyl-check-mbox ()
  600.   "Go through the nnbabyl mbox and make sure that no article numbers are reused."
  601.   (interactive)
  602.   (let ((idents (make-vector 1000 0))
  603.     id)
  604.     (save-excursion
  605.       (when (or (not nnbabyl-mbox-buffer)
  606.         (not (buffer-name nnbabyl-mbox-buffer)))
  607.     (nnbabyl-read-mbox))
  608.       (set-buffer nnbabyl-mbox-buffer)
  609.       (goto-char (point-min))
  610.       (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) "  nil t)
  611.     (if (intern-soft (setq id (match-string 1)) idents)
  612.         (progn
  613.           (delete-region (progn (beginning-of-line) (point))
  614.                  (progn (forward-line 1) (point)))
  615.           (nnheader-message 7 "Moving %s..." id)
  616.           (nnbabyl-save-mail))
  617.       (intern id idents)))
  618.       (when (buffer-modified-p (current-buffer))
  619.     (save-buffer))
  620.       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  621.       (message ""))))
  622.  
  623. (provide 'nnbabyl)
  624.  
  625. ;;; nnbabyl.el ends here
  626.